home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / identifier.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  5.8 KB  |  185 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         identifier.lsp
  5. ; RCS:          $Header: identifier.lsp,v 1.2 91/10/05 17:44:10 mayer Exp $
  6. ; Description:  A useful UI debugging tool. Loading this file creates a panel that
  7. ;        allows you to click on a widget to identify it, click on a widget
  8. ;        to destroy it, or change the foreground and background colors of
  9. ;        the widget you click on. For Motif 1.1, the "Identify Selected Widget"
  10. ;        button becomes especially useful because it will print out the
  11. ;        fully qualified resource name -- this allows setting up your
  12. ;        X-resources on a per widget basis and allows you to better understand
  13. ;        which widgets are affected by a particular setting in your ~/.Xdefaults...
  14. ; Author:       Niels Mayer, HPLabs
  15. ; Created:      Mon Oct 29 02:44:55 1990
  16. ; Modified:     Sat Oct  5 17:40:03 1991 (Niels Mayer) mayer@hplnpm
  17. ; Language:     Lisp
  18. ; Package:      N/A
  19. ; Status:       X11r5 contrib tape release
  20. ;
  21. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  22. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  23. ;
  24. ; Permission to use, copy, modify, distribute, and sell this software and its
  25. ; documentation for any purpose is hereby granted without fee, provided that
  26. ; the above copyright notice appear in all copies and that both that
  27. ; copyright notice and this permission notice appear in supporting
  28. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  29. ; used in advertising or publicity pertaining to distribution of the software
  30. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  31. ; makes no representations about the suitability of this software for any
  32. ; purpose.  It is provided "as is" without express or implied warranty.
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34.  
  35. (let* (toplevel_w
  36.        rc_w identify_pb_w destroy_pb_w
  37.        fg_rc_w fg_la_w fg_ed_w
  38.        bg_rc_w bg_la_w bg_ed_w
  39.        )
  40.  
  41.   (setq toplevel_w
  42.     (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "identshl"
  43.           :XMN_TITLE    "Widget Operations"
  44.           :XMN_ICON_NAME    "WidgetOps"
  45.           ))
  46.   (setq rc_w
  47.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed
  48.           "rc" toplevel_w
  49.           :XMN_PACKING        :no_packing
  50.           :XMN_NUM_COLUMNS        1
  51.           :XMN_ENTRY_ALIGNMENT    :alignment_center
  52.           :XMN_ORIENTATION        :vertical
  53.           ))
  54.   (setq identify_pb_w
  55.     (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed
  56.           "identify" rc_w
  57.           :XMN_LABEL_STRING "Identify Selected Widget"
  58.           ))
  59.   (setq destroy_pb_w
  60.     (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed
  61.           "destroy" rc_w
  62.           :XMN_LABEL_STRING "Destroy Selected Widget"
  63.           ))
  64.   (setq fg_rc_w
  65.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed
  66.           "rc_fgcolor" rc_w
  67.           :XMN_PACKING        :pack_tight
  68.           :XMN_ENTRY_ALIGNMENT    :alignment_center
  69.           :XMN_ORIENTATION        :horizontal
  70.           ))
  71.   (setq fg_la_w
  72.     (send XM_LABEL_WIDGET_CLASS :new :managed
  73.           "label_fgcolor" fg_rc_w
  74.           :XMN_LABEL_STRING "Set Foreground Color\nof Selected Widget:"
  75.           ))
  76.   (setq fg_ed_w
  77.     (send XM_TEXT_WIDGET_CLASS :new :managed
  78.           "edit_fgcolor" fg_rc_w
  79.           :XMN_EDIT_MODE       :single_line_edit
  80.           ))
  81.   (setq bg_rc_w
  82.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed
  83.           "rc_bgcolor" rc_w
  84.           :XMN_PACKING        :pack_tight
  85.           :XMN_ENTRY_ALIGNMENT    :alignment_center
  86.           :XMN_ORIENTATION        :horizontal
  87.           ))
  88.   (setq bg_la_w
  89.     (send XM_LABEL_WIDGET_CLASS :new :managed
  90.           "label_bgcolor" bg_rc_w
  91.           :XMN_LABEL_STRING "Set Background Color\nof Selected Widget:"
  92.           ))
  93.   (setq bg_ed_w
  94.     (send XM_TEXT_WIDGET_CLASS :new :managed
  95.           "edit_bgcolor" bg_rc_w
  96.           :XMN_EDIT_MODE       :SINGLE_LINE_EDIT
  97.           ))
  98.  
  99.   (send toplevel_w :realize)
  100.  
  101.  
  102.   (if (and (eq *MOTIF_VERSION* 1) (eq *MOTIF_REVISION* 0))
  103.       ;; Motif 1.0 version -- method :NAME not def'd in X11r3
  104.       ;; so we can't do all the fancy stuff as done below
  105.       (send identify_pb_w :set_callback :XMN_ACTIVATE_CALLBACK '()
  106.         '(
  107.           (let ((w (get_moused_widget))
  108.             height
  109.             width)
  110.  
  111.         (send w :get_values
  112.               :XMN_HEIGHT 'height
  113.               :XMN_WIDTH  'width)
  114.  
  115.         (format t "\nwidget=~A\n\tparent=~A\n\theight=~A\n\twidth=~A\n"
  116.             w (send w :parent) height width)
  117.         )))
  118.     ;; Motif 1.1/X11r4 version -- attempts to print fully qualified
  119.     ;; resource name. Note that more work needs to be done on resource
  120.     ;; name printing... current logic was hacked, not designed.
  121.     (send identify_pb_w :set_callback :XMN_ACTIVATE_CALLBACK '()
  122.       '(
  123.         (let ((w (get_moused_widget))
  124.           height
  125.           width)
  126.  
  127.           (send w :get_values
  128.             :XMN_HEIGHT 'height
  129.             :XMN_WIDTH  'width)
  130.  
  131.           (format t "\nwidget=~A\n\tparent=~A\n\theight=~A\n\twidth=~A\n"
  132.               w (send w :parent) height width)
  133.  
  134.           (let* ((name (send w :name))
  135.              (resname (if (string= name "") "*" name))
  136.              (wildcard-p nil))
  137.   
  138.         (loop
  139.  
  140.          (if (null (setq w (send w :parent)))
  141.              (return (format t "\tX-resource = ~A\n" resname)))
  142.  
  143.          (setq name (send w :name))
  144.          (cond ((string= name "")
  145.             (cond ((not wildcard-p)
  146.                    (setq resname (strcat "*" resname))
  147.                    (setq wildcard-p t)))
  148.             )
  149.                (t
  150.             (cond (wildcard-p
  151.                    (setq resname (strcat name resname))
  152.                    (setq wildcard-p nil)
  153.                    )
  154.                   (T
  155.                    (setq resname (strcat name "." resname))
  156.                    )
  157.                   ))
  158.                )
  159.          ))
  160.           )))
  161.     )
  162.  
  163.   (send destroy_pb_w :set_callback :XMN_ACTIVATE_CALLBACK '()
  164.     '(
  165.       (send (get_moused_widget) :destroy)
  166.       ))
  167.  
  168.   (send fg_ed_w :set_callback :XMN_ACTIVATE_CALLBACK
  169.     '(CALLBACK_WIDGET)
  170.     '(
  171.       (send (get_moused_widget) :set_values
  172.         :XMN_FOREGROUND (send CALLBACK_WIDGET :get_string)
  173.         )
  174.       ))
  175.  
  176.   (send bg_ed_w :set_callback :XMN_ACTIVATE_CALLBACK
  177.     '(CALLBACK_WIDGET)
  178.     '(
  179.       (send (get_moused_widget) :set_values
  180.         :XMN_BACKGROUND (send CALLBACK_WIDGET :get_string)
  181.         )
  182.       ))
  183.  
  184.   )
  185.